home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Memphis Amiga Group / MAG Disk (1989-11)(Memphis Amiga Group).zip / MAG Disk (1989-11)(Memphis Amiga Group).adf / HeadClean / gadget_tools < prev    next >
Text File  |  1986-11-06  |  3KB  |  110 lines
  1. \ General Purpose Gadget tools
  2. \ originally used in HeadClean program.
  3. \
  4. \ Author: Phil Burk
  5. \ Public Domain, Freely Redistributable
  6.  
  7. include? gr.init ju:amiga_graph
  8. include? ev.getclass ju:amiga_events
  9. include? boolean.setup ju:gadget_support
  10.  
  11. ANEW TASK-GADGET_TOOLS
  12.  
  13. variable FIRST-GADGET  ( first in linked list )
  14. variable LAST-GADGET   ( last one defined )
  15.  
  16. \ Border for gadget
  17. border BOOLG-BORDER
  18. create BOOLG-XYS 5 cells allot
  19.  
  20. : GT.GAD.FREE ( gadget -- , free intuitext and gadget )
  21.     dup ..@ gg_gadgetText if>rel ?dup
  22.     IF freeblock
  23.     THEN
  24.     freeblock
  25. ;
  26.  
  27. : GT.FREE.ALL  ( -- , free all gadgets )
  28.     first-gadget @
  29.     BEGIN dup 
  30.     WHILE dup ..@ gg_nextgadget if>rel swap
  31.         gt.gad.free
  32.     REPEAT drop
  33.     first-gadget off
  34. ;
  35.  
  36. : GT.ABORT ( -- , free gadgets then abort )
  37.     gt.free.all
  38.     abort
  39. ;
  40.  
  41. \ Gadgets will be dynamically allocated and initialized,
  42. \ then linked to the end of the gadget chain.
  43. \ You could use this word in other programs after
  44. \ customizing it.
  45.  
  46. : GT.GAD.MAKE ( cfa text x y w h -- , allocate and build a gadget)
  47. \ Allocate a Gadget structure
  48.     allocstruct gadget ?dup
  49.     IF dup>r menubutton.setup   ( set defaults )
  50. \ Allocate IntuiText structure
  51.       allocstruct IntuiText ?dup
  52.       IF dup >abs r@ ..! gg_gadgettext  ( use it )
  53.         itext.setup   ( eat text and setup Intuitext )
  54. \ Use the border to draw gadget.
  55.         boolg-border >abs r@ ..! gg_gadgetrender
  56. \ Store CFA in Gadget for PROCESS.GADGET to execute
  57.         r@ ..! gg_userdata
  58. \ Seems to be needed for proper highlighting
  59.         RELVERIFY r@ ..! gg_Activation
  60. \ Link to last gadget in chain
  61.         first-gadget @ 0=
  62.         IF r@ first-gadget !
  63.         ELSE r@ >abs last-gadget @ ..! gg_nextgadget
  64.         THEN
  65.         r@ last-gadget !
  66.       ELSE 2drop ." Couldn't allocate Intuitext" gt.abort
  67.       THEN
  68.       rdrop
  69.     ELSE 6 xdrop ." Couldn't allocate Gadget" gt.abort
  70.     THEN
  71. ;
  72.  
  73. : GT.PROCESS.GADGET  ( gadget -- , execute CFA in gadget)
  74.     ..@ gg_userdata ?dup
  75.     IF execute  ( do NOT pass gadget address )
  76.     ELSE ." NO CFA!"
  77.     THEN
  78. ;
  79.  
  80. : GT.REFRESH  ( -- , refresh gadgets )
  81.     first-gadget @
  82.     gr-curwindow @    ( assume in current window )
  83.     NULL
  84.     refreshgadgets()
  85. ;
  86.  
  87.  
  88. variable IF-QUIT
  89.  
  90. : GT.PROCESS.EVENT ( class -- done? , process events from IDCMP )
  91.     false if-quit !
  92.     CASE 
  93.         GADGETUP  ( execute CFA stored in gadget )
  94.             OF ev-last-iaddress @ ( -- gadget )
  95.                 >rel gt.process.gadget
  96.             ENDOF
  97.  
  98.         GADGETDOWN  ( just wait for UP )
  99.             OF noop
  100.             ENDOF
  101.  
  102.         CLOSEWINDOW ( set var to quit )
  103.             OF true if-quit !
  104.             ENDOF
  105.  
  106.         ." GADGET.LOOP -- Unrecognized event = " dup . cr
  107.     ENDCASE
  108.     if-quit @
  109. ;
  110.